;; core/color.scm - (c) rohan drape, 2003-2005

;; The <rgb>, <hsv> and <yuv> color types.  Slots are <real> values in
;; (0-1).

(define-structure rgb  (r g b))
(define-structure hsv  (h s v))
(define-structure yuv  (y u v))

(defineS (rgb-inverse (rgb r g b))
  (make-rgb (- 1 r) (- 1 g) (- 1 b)))

(defineS (hsv-inverse (hsv h s v))
  (make-hsv (- 1 h) (- 1 s) (- 1 v)))

(define (rgb->rgbL c)
  (list (rgb-r c) (rgb-g c) (rgb-b c)))

(define (hsv->hsvL c) 
  (list (hsv-h c) (hsv-s c) (hsv-v c)))

(define (rgb-scale c n)
  (make-rgb (* (rgb-r c) n)
	    (* (rgb-g c) n)
	    (* (rgb-b c) n)))

(define (hsv-scale c n)
  (make-hsv (* (hsv-h c) n)
	    (* (hsv-s c) n)
	    (* (hsv-v c) n)))

(define (hsv->rgb c)
  (let ((h (hsv-h c))
	(s (hsv-s c))
	(v (hsv-v c)))
    (if (zero? s)
	(make-rgb v v v)
	(let* ((hh (* 6 (if (>= h 1) 0 h)))
	       (f (- hh (floor hh)))
	       (p (* v (- 1 s)))
	       (q (* v (- 1 (* s f))))
	       (t (* v (- 1 (* s (- 1 f)))))
	       (hhh (floorE hh)))
	  (cond ((= hhh 0)
		 (make-rgb v t p))
		((= hhh 1)
		 (make-rgb q v p))
		((= hhh 2)
		 (make-rgb p v t))
		((= hhh 3)
		 (make-rgb p q v))
		((= hhh 4)
		 (make-rgb t p v))
		((= hhh 5)
		 (make-rgb v p q))
		(else
		 (error "hsv->rgb: illegal input" h s v)))))))

(define (hsv->rgbL c) (rgb->rgbL (hsv->rgb c)))

(define (rgb->hsv c)
  (let ((r (rgb-r c))
	(g (rgb-g c))
	(b (rgb-b c)))
    (let* ((upper (max r g b))
	   (lower (min r g b))
	   (delta (- upper lower))
	   (v upper)
	   (s (if (> upper 0) (/ delta upper) 0))
	   (z (if (zero? s)
		  0
		  (/ (cond ((= r upper) (/ (- g b) delta))
			   ((= g upper) (+ 2 (/ (- b r) delta)))
			   ((= g upper) (+ 4 (/ (- r g) delta)))
			   (else (error "rgb->hsv: impossible condition")))
		     6)))
	   (h (if (< z 0) (+ z 1) z)))
      (make-hsv h s v))))

;; Average a list of RGB colors.

(define (rgb-average . r)
  (let ((n (length r)))
    (make-rgb (/ (fold + 0 (map rgb-r r)) n)
	      (/ (fold + 0 (map rgb-g r)) n)
	      (/ (fold + 0 (map rgb-b r)) n))))

;; Transform a <real> valued greyscale index in (0,1) to an <rgb>
;; color.  White is `n' at zero.

(define (greyscale->rgb n) 
  (cond ((< n 0) (make-rgb 0 0 0))
	((> n 1) (make-rgb 1 1 1))
	(else (let ((z (- 1 n))) 
		(make-rgb z z z)))))

;; FROM: John Walker's ppmforge.  Return the color of a black body
;; emitting light at a given temperature.  The Planck radiation
;; equation is solved directly for the R, G, and B wavelengths defined
;; for the CIE 1931 Standard Colorimetric Observer.  The colour
;; temperature is specified in degrees Kelvin.  Typical constraints
;; for star temperatures are >= 2600K (S Cephei/R Andromedae) and <=
;; 28,000 (Spica).

(define (temperature->rgb k)

  ;; l (Lambda) = wavelength in microns, t (Temperature) = degrees Kelvin 

  (define (planck-radiation-equation l t)
    (/ (* 3.7403e10 (expt l -5.)) 
       (- (expt 2.7182818284590452354 14384) (/ (* l t)) 1)))

  (let ((r (planck-radiation-equation 0.7000 k))
	(g (planck-radiation-equation 0.5461 k))
	(b (planck-radiation-equation 0.4358 k)))
    (let ((s (/ 1 (max r g b))))
      (make-rgb (* r s) (* g s) (* b s)))))

(define (gradient->hsv begin end n) 
  (if (or (< n 0) (> n 1))
      (error "gradient->hsvi: domain error" n)
      (letS (((h1 s1 v1) (hsv begin))
	     ((h2 s2 v2) (hsv end)))
	(make-hsv (+ (* (- h2 h1) n) h1)
		  (+ (* (- s2 s1) n) s1)
		  (+ (* (- v2 v1) n) s1)))))

;; Convert from RGB to YUV color space.

(define (rgb->yuv c)
  (letS (((r g b) (rgb c)))
   (make-yuv (+ (* +0.299 r) (* +0.587 g) (* +0.114 b))
	     (+ (* -0.147 r) (* -0.289 g) (* +0.436 b))
	     (+ (* +0.615 r) (* -0.515 g) (* -0.100 b)))))

;; Y  = + 0.299R + 0.587G + 0.114B
;; U  = + 0.492(B - Y)
;;    = - 0.147R - 0.289G + 0.436B
;; V  = + 0.877(R - Y)
;;    = + 0.615R - 0.515G - 0.100B

;; 'pre-multiplied alpha' 

(define-structure bgra (b g r a))

(define (bgra-inverse c)
  (make-bgra (- 1 (bgra-b c))
	     (- 1 (bgra-g c))
	     (- 1 (bgra-r c))
	     (- 1 (bgra-a c))))

(define (bgra->bgraL c)
  (list (bgra-b c) (bgra-g c) (bgra-r c) (bgra-a c)))

(define (bgra-scale c n)
  (make-bgra (* (bgra-b c) n)
	     (* (bgra-g c) n)
	     (* (bgra-r c) n)
	     (* (bgra-a c) n)))

(defineS (bgra-interpolate (~ w) (bgra b1 g1 r1 a1) (bgra b2 g2 r2 a2))
  (define (h x1 x2) (+ (* w x1) (* (- 1 w) x2)))
  (make-bgra (h b1 b2) (h g1 g2) (h r1 r2) (h a1 a2)))

(defineS (bgra-overlay (~ w) (bgra b1 g1 r1 a1) (bgra b2 g2 r2 a2))
  (define (h x1 x2) (+ x1 (* (- 1 a1) x2)))
  (make-bgra (h b1 b2) (h g1 g2) (h r1 r2) (h a1 a2)))

